home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / Binhex / binhex.lisp
Encoding:
Text File  |  1993-09-16  |  37.6 KB  |  946 lines  |  [TEXT/CCL2]
  1. ;;;-*-Mode: LISP; Package: CCL -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;;
  5. ;;; Binhex.lisp is an example of creation of a standalone application with no
  6. ;;; Lisp listener in evidence.
  7. ;;; The first section contains the code for encoding and decoding
  8. ;;; files in binhex format.
  9. ;;; The second section contains the menu and dialogs for the user interface.
  10. ;;; and installs the binhex menu in the current environment.
  11. ;;; We have not attempted to create carefully worded beautiful dialogs.
  12. ;;; The last section contains the functions for making a standalone
  13. ;;; binhex application. Do  (ccl::SAVE-BINHEX pathname) to make the application.
  14.  
  15. ;;;;;;;;;;;;;;;;;;
  16. ;;; Modification history
  17. ;; 04/28/93 mwp Release
  18. ;; 06/22/92 alice fix for finder selected files when already running (requires appleevents-patch)
  19. ;;           and change bit-bucket stream to an empty broadcast stream
  20. ;;---------- 2.0
  21. ;; 01/15/91 alice some folks do rle in header too.
  22. ;; 12/10/91 alice  handle file errors 
  23.  
  24. (in-package :ccl)
  25.  
  26. (eval-when (:compile-toplevel :execute :load-toplevel)
  27.   (require :lispequ)
  28.   (require :resources))
  29.  
  30. ; to do - an  icon and bundle bit
  31.  
  32. ; magic number for the crc calculation
  33. (defconstant magic #.(ash #x1021 8))
  34.  
  35. ; encoding translation table
  36. (defconstant char-table
  37.   "!\"#$%&'()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr")
  38.  
  39.  
  40. ; the  file creator for encoded binhex files
  41. (defconstant binhex-file-creator :|BnHQ|)
  42.  
  43. ; this value denotes a white space character in the decoding translation table
  44. (defconstant return-code #xc0)
  45.  
  46. (defconstant colon-code (char-code #\:))
  47.  
  48. (defparameter decode-table nil)
  49.  
  50. (defparameter crc-table (make-array 256))
  51.  
  52. ;;; Create the table used by the crc calculation.
  53. (defun make-crc ()
  54.   (dotimes (i 256)
  55.     (setf (svref crc-table i)
  56.           (let ((mgc (ash magic -1))
  57.                 (val (ash i 16)))
  58.             (do ((bit 23 (1- bit)))
  59.                 ((<= bit 15))
  60.               (when (logbitp bit val)
  61.                 (setq val (logxor val mgc)))
  62.               (setq mgc (ash mgc -1)))
  63.             (logand val #xffff)))))
  64.  
  65. ; xor f(crc high byte) with crc low byte and new byte
  66.  
  67. (defmacro crc-byte (crc byte)
  68.   (let ((cc (gensym))(bb (gensym)))
  69.     `(let ((,cc ,crc)(,bb ,byte))
  70.        (declare (type (unsigned-byte 16) ,cc)(type (unsigned-byte 8) ,bb)
  71.                 (type (simple-vector fixnum 256) crc-table))
  72.        (logand #xffff (logxor (the fixnum (svref  crc-table (the (unsigned-byte 8)(ash ,cc -8))))
  73.                               (logior (ash ,cc 8) ,bb))))))
  74. #|
  75. (defun crc-byte (crc byte)
  76.   (declare (type (unsigned-byte 16) crc)(type (unsigned-byte 8) byte)
  77.            (type (simple-array fixnum 256) crc-table))
  78.   (logand #xffff (logxor (the fixnum (svref crc-table (the (unsigned-byte 8)(ash crc -8))))
  79.                          (logior (ash crc 8) byte))))
  80. |#
  81.  
  82. ;;; above is equivalent to
  83. #|
  84. (defun crc-byte (crc byte)
  85.    (let ((foo (logior (ash crc 8) byte)) (mgc magic))
  86.       (dotimes (i 8)
  87.         (setq foo (ash foo 1))
  88.         (when (logbitp 24 foo)
  89.           (setq foo (logxor foo mgc))))
  90.       (logand #xffff (ash foo -8))))
  91. |#
  92.     
  93.  
  94. ; set up decoding translation table
  95. ; #xFF denotes a character that should not appear in the binhex stream
  96. (eval-when (:execute :load-toplevel)
  97.     (setq decode-table
  98.           (make-array 256 #|:element-type '(unsigned-byte 8)|# :initial-element #xFF))
  99.     (dotimes (i (length char-table))
  100.       (let ((code (char-code (schar char-table i))))
  101.         (setf (aref decode-table code) i)))
  102.     (dolist (c '(#\newline #\return #\linefeed #\tab #\space))
  103.       (setf (aref decode-table  (char-code c)) return-code))
  104.     (make-crc))
  105.  
  106.   
  107.  
  108. ; the full header to print at the front of a binhex file
  109. (defconstant full-header
  110.   "(This file must be converted with BinHex 4.0)
  111. :")
  112.  
  113. ; that part of the header to check when decoding a binhex file
  114. (defconstant short-header
  115.   "This file must be converted with BinHex")
  116.  
  117. ;;; Define a new stream class and a few methods.
  118. ;;;  Avoids making a string when decoding a selection in a Fred window.
  119. (defclass fred-input-stream (input-stream)
  120.   ((my-buffer :initarg :buffer)
  121.    (index :initarg :start :initform nil)
  122.    (pathname :initform "a Fred selection" :reader stream-filename)
  123.    (end :initarg :end :initform nil)))
  124.  
  125. (defmethod instance-initialize :after ((stream fred-input-stream) &key)
  126.   (let* ((buffer (slot-value stream 'my-buffer))
  127.          (index (or (slot-value stream 'index) 0))
  128.          (length (buffer-size buffer))
  129.          (end (or (slot-value stream 'end) length)))
  130.     (unless (<= 0 end length) (error "End ~S not between 0 and length ~S" end length))
  131.     (unless (<= 0 index end) (error "Index ~S not between 0 and end ~S" index end))
  132.     (setf (slot-value stream 'index) index)
  133.     (setf (slot-value stream 'end) end)))
  134.  
  135. (defmethod stream-read-byte ((stream fred-input-stream))
  136.   (let ((idx (slot-value stream 'index)))
  137.     (declare (fixnum idx))
  138.     (when (< idx (the fixnum (slot-value stream 'end)))
  139.       (setf (slot-value stream 'index) (the fixnum (+ idx 1)))
  140.       (char-code (buffer-char (slot-value stream 'my-buffer) idx)))))
  141.  
  142. (defmethod stream-reader ((stream fred-input-stream))
  143.   (values (method-function (method stream-read-byte (fred-input-stream)))
  144.           stream))
  145.  
  146. (defmethod file-length ((stream fred-input-stream) &optional ignore)
  147.   (declare (ignore ignore))
  148.   (- (slot-value stream 'end)(slot-value stream 'index)))
  149.  
  150. (defmethod stream-position ((stream fred-input-stream) &optional position)
  151.   (if position
  152.     (setf (slot-value stream 'index) position)
  153.     (slot-value stream 'index)))
  154.  
  155. ; do I need this?
  156. (defmethod stream-eofp ((stream fred-input-stream))
  157.   (eq (slot-value stream 'index) (slot-value stream 'end)))
  158.  
  159. (defmethod stream-close :after ((stream fred-input-stream))
  160.   (slot-makunbound stream 'my-buffer))
  161.  
  162. (defclass binhex-application (application)
  163.   ())
  164.  
  165.  
  166. (defun binhex-decode (infile &optional outfile)
  167.   (with-open-file (s infile :direction :input :element-type '(unsigned-byte 8))
  168.     (binhex-decode-stream s outfile infile)))
  169.  
  170. ; bx-byte reads a byte from the binhex file - gets the 6 bit translation
  171. ; combines those bits with some left over from the last 6 bit translation
  172. ; and returns 8 bits for output. Note that we cannot do the
  173. ; CRC here because the byte(s) actually output may be different.
  174.  
  175.  
  176. (defun bx-byte (reader readarg)
  177.   (declare (special bits-left count last-nibble last-byte istream))
  178.   (declare (type (unsigned-byte 8) bits-left last-nibble))  
  179.   (declare (fixnum count))
  180.   (declare (optimize (speed 3)(safety 0)))
  181.   (flet 
  182.     ((bx-error ()
  183.        (error (make-condition 'file-error
  184.                               :pathname (let ((fn (stream-filename istream)))
  185.                                           (or (probe-file fn) fn))
  186.                               :error-type "End of file ~S"
  187.                               :format-arguments nil))))       
  188.     (macrolet
  189.       ((read-byte-reader ()
  190.          `(let ((c (funcall reader readarg)))
  191.             (cond
  192.              (c (locally (declare (type (unsigned-byte 8) c))
  193.                   ;(when (eq c colon-code)(binhex-error "premature colon in ~A" istream))                   
  194.                   (setq c (svref table c))
  195.                   (when (eq c #xFF) (binhex-error "~A contains an illegal character" istream))
  196.                   (loop (when (neq c return-code)(return))
  197.                         (setq c (svref table (funcall reader readarg))))
  198.                   c))
  199.              (t (bx-error)))))
  200.        (bx-byte-sub ()
  201.          `(let ((c1 (read-byte-reader)))
  202.             (declare (type (unsigned-byte 8) c1))
  203.             (case bits-left
  204.               (0
  205.                (setq last-nibble  (read-byte-reader))
  206.                (setq bits-left 4)
  207.                (logior (ash c1  2)(ash last-nibble -4)))
  208.               (4
  209.                (setq bits-left 2)
  210.                (logior (logand #xf0 (ash last-nibble 4))
  211.                        (ash (setq last-nibble c1) -2)))
  212.               (t (setq bits-left 0)
  213.                  (logand #xff (logior (ash last-nibble 6) c1)))))))    
  214.       (let ((table decode-table))
  215.         (declare (type (simple-array fixnum 256) table))
  216.         (cond ((> count 0)
  217.                (setq count (1- count)))
  218.               (t (let ((byte (bx-byte-sub)))
  219.                    (cond 
  220.                     ((and (eq  byte #x90)(neq 0 (setq count (bx-byte-sub))))
  221.                      (setq count (- count 2)))
  222.                     (t (setq last-byte byte))))))
  223.         last-byte))))
  224.  
  225. (defun binhex-decode-stream (istream &optional outfile (infile istream))
  226.   (declare (special istream))
  227.   (declare (optimize (speed 3)(safety 0)))
  228.   (let ((bits-left 0)(last-nibble 0)(count 0) last-byte)
  229.     (declare (special bits-left count last-nibble last-byte))
  230.     (declare (type (unsigned-byte 8) bits-left last-nibble))
  231.     (declare (fixnum count))
  232.     (multiple-value-bind (reader readarg)(stream-reader istream)
  233.         (macrolet
  234.           ((bx-long ()            
  235.              `(let ((c1 (bx-byte reader readarg))(c2 (bx-byte reader readarg))
  236.                     (c3 (bx-byte reader readarg))(c4 (bx-byte reader readarg)))
  237.                 (setq crc (crc-byte (crc-byte (crc-byte (crc-byte crc c1) c2) c3) c4))
  238.                 (logior
  239.                  (ash c1 24)
  240.                  (ash c2 16)
  241.                  (ash c3 8)
  242.                  c4))))
  243.           (let ((c 0))
  244.             (declare (fixnum c))
  245.             (when (not (find-binhex-header istream))
  246.               (binhex-error "~A does not have a binhex header" infile))
  247.             ; skip to return
  248.             (loop 
  249.               (setq c (read-byte istream))
  250.               (unless (eq c (char-code #\space))
  251.                 (when (eq (aref decode-table c) return-code)
  252.                   (return))))
  253.             ; skip returns til colon
  254.             (loop
  255.               (setq c (read-byte istream))
  256.               (when (eq c colon-code) (return))
  257.               (when (neq (aref decode-table c) return-code)
  258.                 (binhex-error "Bad stuff in text header of ~A" infile)))
  259.             ; time to read the header describing the contents
  260.             (let* ((namelength (bx-byte reader readarg))
  261.                    (name (make-string namelength))
  262.                    (type (make-string 4))
  263.                    (creator (make-string 4))
  264.                    (crc 0)
  265.                    flags dlen rlen hdr-crc)
  266.               ; get the filename - will be the default for the dialog
  267.               (setq crc (crc-byte 0 namelength))
  268.               (dotimes (i namelength)
  269.                 (declare (fixnum i))
  270.                 (let ((c (bx-byte reader readarg)))
  271.                   (setq crc (crc-byte crc c)) 
  272.                   (setf (aref name i)(code-char c))))
  273.               ; skip a 0 byte
  274.               (when (neq 0 (bx-byte reader readarg))(binhex-error "Error reading file name in header of ~A" infile))
  275.               (setq crc (crc-byte crc 0))
  276.               (when (null outfile)
  277.                 (setq outfile
  278.                       (catch-cancel (choose-new-file-dialog :directory name)))
  279.                 (when (eq outfile :cancel)(return-from binhex-decode-stream nil)))
  280.               (with-cursor *watch-cursor*  ; have to do this after the modal dialog
  281.                 ; get mac type and creator
  282.                 (dotimes (i 4)
  283.                   (declare (fixnum i))
  284.                   (let ((c (bx-byte reader readarg)))
  285.                     (setq crc (crc-byte crc c))            
  286.                     (setf (aref type i) (code-char c))))
  287.                 (setq type (intern type (find-package :keyword)))
  288.                 (dotimes (i 4)
  289.                   (declare (fixnum i))            
  290.                   (let ((c (bx-byte reader readarg)))
  291.                     (setq crc (crc-byte crc c))              
  292.                     (setf (aref creator i)(code-char c))))
  293.                 (setq creator (intern creator (find-package :keyword)))
  294.                 ; finder flags
  295.                 (let ((c (bx-byte reader readarg)) (c2 (bx-byte reader readarg)))
  296.                   (setq crc (crc-byte (crc-byte crc c) c2))
  297.                   (setq flags (logior (ash c 8) c2)))
  298.                 ; lengths of data and resource forks
  299.                 (setq dlen (bx-long))
  300.                 (setq rlen (bx-long))
  301.                 (setq crc (crc-byte (crc-byte crc 0) 0))
  302.                 (setq hdr-crc (logior (ash (bx-byte reader readarg) 8)(bx-byte reader readarg)))
  303.                 (when (neq crc hdr-crc) (binhex-error "crc failure in header of ~A" infile))
  304.                 (binhex-decode-sub outfile reader readarg type creator dlen :data)
  305.                 (binhex-decode-sub outfile reader readarg type creator rlen :resource)
  306.                 (set-finder-flags outfile
  307.                                   (logand flags
  308.                                           (lognot (+  (ash 1 8) ;#$fInitted  - where is he
  309.                                                       #$fOnDesk
  310.                                                       #$fInvisible))))
  311.                 outfile)))))))
  312.  
  313. (defun set-finder-flags (file flags)
  314.   (%stack-iopb (pb np)
  315.     (%path-to-iopb file pb :errchk)
  316.     (setf (pref pb hparamblockrec.ioFlFndrInfo.fdFlags) flags)
  317.     (file-errchk (#_HSetFInfo pb) file)))
  318.  
  319. (defun get-finder-flags (file)
  320.   (%stack-iopb (pb np)
  321.     (%path-to-iopb file pb :errchk)
  322.     (pref pb hparamblockrec.ioFlFndrInfo.fdFlags)))
  323.     
  324.  
  325.  
  326. (defun find-binhex-header (s)
  327.   (let ((hlength (length short-header))
  328.          (flength (file-length s))
  329.          (pos))
  330.     (declare (fixnum hlength flength))
  331.     (declare (optimize (speed 3)(safety 0)))
  332.     (dotimes (i (- flength hlength) nil)
  333.       (declare (fixnum i))
  334.       (let ((c (code-char (read-byte s))))
  335.         (when (eq c (schar short-header 0))
  336.           (setq pos (stream-position s))
  337.           (when (dotimes (i (1- hlength) t)
  338.                   (declare (fixnum i))
  339.                   (when (neq (schar short-header (1+ i)) (code-char (read-byte s)))
  340.                     (return nil)))
  341.             (return-from find-binhex-header t))
  342.           (stream-position s  pos))))))
  343.  
  344. ; decode the resource or data fork section of the binhex data file
  345.  
  346. (defun binhex-decode-sub (outfile reader readarg type creator dlen fork)
  347.   (declare (optimize (speed 3)(safety 0)))
  348.   (declare (special istream))
  349.   (with-open-file (ostream outfile :direction :output
  350.                            :if-exists (if (eq fork :data) :supersede :overwrite)
  351.                            :external-format type
  352.                            :mac-file-creator creator
  353.                            :fork fork
  354.                            :element-type '(unsigned-byte 8))
  355.     (multiple-value-bind (writer writearg)(stream-writer ostream)      
  356.       (let ((crc 0))
  357.         (do ((i dlen (1- i)))
  358.             ((<= i 0))
  359.           ; does the length include the crc? assume not
  360.           (let ((byte (bx-byte reader readarg)))
  361.             (funcall writer writearg byte)
  362.             (setq crc (crc-byte crc byte))))
  363.         ; account for 2 crc bytes as if zero
  364.         (setq crc (crc-byte crc 0))(setq crc (crc-byte crc 0))
  365.         (when (not (and (eq  (logand #xFF (ash crc -8))(bx-byte reader readarg))
  366.                         (eq (logand #xff crc)(bx-byte reader readarg))))
  367.           (binhex-error "crc failure in ~A" istream))))))
  368.  
  369.  
  370. ; bx-out
  371. ; given 8 bits to output, combines some of the high bits with some of the low
  372. ; bits of the last byte, to get a 6 bit byte which is translated and output
  373. ; in one case 2 translated 6 bit bytes are output
  374. ; Also inserts a #\newline every 64 characters
  375.  
  376. (defun bx-out (writer writearg byte &aux (table char-table))
  377.   (declare (special last-byte bits-left nchars))
  378.   (declare (fixnum nchars)(type (unsigned-byte 8) byte last-byte))
  379.   (declare (optimize (speed 3)(safety 0)))
  380.   (case bits-left
  381.     (0 (funcall writer writearg (schar table (ash byte -2)))         
  382.      (setq last-byte byte)
  383.      (setq bits-left 2))
  384.     (2 (funcall writer writearg (schar table (logand #o77 (logior 
  385.                                                            (ash last-byte 4)
  386.                                                            (ash byte -4)))))
  387.      (setq last-byte byte)
  388.      (setq bits-left 4))
  389.     (t (funcall writer writearg (schar table (logand #o77 (logior (ash last-byte 2)
  390.                                                                   (ash byte -6)))))
  391.        (setq nchars (1+ nchars))
  392.        (when (> nchars 63)
  393.          (funcall writer writearg #\newline)
  394.          (setq nchars 0))             
  395.        (funcall writer writearg (schar table (logand byte #o77)))
  396.        (setq bits-left 0)))
  397.   (setq nchars (1+ nchars))
  398.   (when (> nchars 63)
  399.     (funcall writer writearg #\newline)
  400.     (setq nchars 0))
  401.   byte)
  402.  
  403. (defun binhex-encode (infile outfile &aux (crc 0) dlen rlen)
  404.   (declare (optimize (speed 3)(safety 0)))
  405.   (let ((bits-left 0)
  406.         (nchars 1)   ; 1 for the initial ":" on the first line
  407.         (last-byte 0)
  408.         writer writearg)
  409.     (declare (special nchars bits-left last-byte))
  410.     (declare (type (unsigned-byte 8) bits-left  last-byte))
  411.     (declare (fixnum nchars))    
  412.     (macrolet
  413.       ((bx-out-long (n)
  414.          (let ((sym (gensym)))         
  415.            `(let* ((,sym ,n) (byte (logand #xff (ash ,sym -24))))
  416.               (bx-out writer writearg byte)
  417.               (setq crc (crc-byte crc byte))
  418.               (bx-out writer writearg (setq byte (logand #xff (ash ,sym -16))))
  419.               (setq crc (crc-byte crc byte))
  420.               (bx-out writer writearg (setq byte (logand #xff (ash ,sym  -8))))
  421.               (setq crc (crc-byte crc byte))
  422.               (bx-out writer writearg (setq byte (logand #xff ,sym)))
  423.               (setq crc (crc-byte crc byte)))))
  424.        (bx-out-string (string)
  425.          (let ((sym (gensym)))
  426.            `(let ((,sym ,string))
  427.               (dotimes (i (length ,sym))
  428.                 (declare (fixnum i))
  429.                 (let ((c (char-code (schar ,sym i))))
  430.                   (bx-out writer writearg c)
  431.                   (setq crc (crc-byte crc c))))))))
  432.       (catch-cancel
  433.         (with-open-file (istream infile :direction :input :element-type '(unsigned-byte 8))
  434.           (setq infile (pathname istream))
  435.           (setq dlen (file-length istream)))
  436.         (with-open-file (istream infile :direction :input :element-type '(unsigned-byte 8)
  437.                                  :fork :resource)
  438.           (setq rlen (file-length istream)))
  439.         (with-cursor *watch-cursor*
  440.           (with-open-file (ostream outfile :direction :output :if-exists :supersede
  441.                                    :mac-file-creator binhex-file-creator)            
  442.             (multiple-value-setq (writer writearg)(stream-writer ostream))
  443.             (setq outfile (pathname ostream))
  444.             (stream-write-entire-string ostream full-header)
  445.             (let* ((name (file-namestring infile))
  446.                    (length (length name)))
  447.               ; now we encode and compute crc for the header
  448.               (bx-out writer writearg length)
  449.               (setq crc (crc-byte crc length))
  450.               (bx-out-string name)
  451.               (bx-out writer writearg 0)
  452.               (setq crc (crc-byte crc 0))
  453.               (bx-out-string (symbol-name (mac-file-type infile)))
  454.               (bx-out-string (symbol-name (mac-file-creator infile)))
  455.               (let ((flags (get-finder-flags infile)) byte)  ; get the finder flags
  456.                 (bx-out writer writearg (setq byte (ash flags -8)))
  457.                 (setq crc (crc-byte crc byte))
  458.                 (bx-out writer writearg (setq byte (logand #xFF flags)))
  459.                 (setq crc (crc-byte crc byte)))
  460.               (bx-out-long dlen)
  461.               (bx-out-long rlen)
  462.               (setq crc (crc-byte (crc-byte crc 0) 0))
  463.               (bx-out writer writearg  (ash crc -8))
  464.               (bx-out writer writearg (logand #xff crc))
  465.               ; at last we get to do the real work
  466.               (binhex-encode-sub infile dlen :data writer writearg)
  467.               (binhex-encode-sub infile rlen :resource writer writearg)          
  468.               (bx-out writer writearg 0)  ; pump out the last bits - may cause extra ! which is ok.
  469.               (stream-tyo ostream #\:)))) ; now we must be done        
  470.         outfile))))
  471.  
  472. ; Encode a fork with run length encoding. I belive stuffit does not do this or if
  473. ; it does, it has a different threshold.
  474.  
  475. (defun binhex-encode-sub (infile file-length fork writer writearg)
  476.   (declare (optimize (speed 3)(safety 0)))
  477.   (with-open-file (istream infile :direction :input :element-type '(unsigned-byte 8) :fork fork)
  478.     (multiple-value-bind (reader readarg)(stream-reader istream)
  479.       (flet ((ferror ()
  480.                (error (make-condition 'file-error
  481.                                       :pathname  (stream-filename istream)
  482.                                       :error-type "End of file ~S"
  483.                                       :format-arguments nil))))        
  484.         (let ((crc 0) byte last-byte)
  485.           (declare (fixnum crc))
  486.           (do ((i file-length (1- i)))
  487.               ((<= i 0))
  488.             ;(declare (fixnum i))
  489.             (setq byte (or (funcall reader readarg) (ferror)))
  490.             (setq crc (crc-byte crc byte))
  491.             (when (eq byte last-byte)
  492.               (let ((count 2))
  493.                 (declare (fixnum count))
  494.                 (loop
  495.                   (when (<= i 1)(setq byte nil) (return))
  496.                   (setq byte (or (funcall reader readarg)(ferror)))
  497.                   (setq i (1- i))
  498.                   (setq crc (crc-byte crc byte))
  499.                   (when (neq byte last-byte)(return))
  500.                   (setq count (1+ count)))
  501.                 (while (> count 255)
  502.                   (bx-out writer writearg #x90)
  503.                   (bx-out writer writearg 255)
  504.                   (setq count (- count 255))
  505.                   (bx-out writer writearg last-byte)
  506.                   (when (eq last-byte #x90)(bx-out writer writearg 0)))
  507.                 (cond ((or (> count 3)(and (eq last-byte #x90)(> count 1)))
  508.                        (bx-out writer writearg #x90)
  509.                        (bx-out writer writearg count))
  510.                       ((< count 2))
  511.                       (t (when (eq count 3) (bx-out writer writearg last-byte))
  512.                          (bx-out writer writearg last-byte)))))
  513.             (when byte 
  514.               (bx-out writer writearg byte)
  515.               (when (eq byte #x90) (bx-out writer writearg 0)))
  516.             (setq last-byte byte))
  517.           (setq crc (crc-byte (crc-byte crc 0) 0))
  518.           (bx-out writer writearg (ash crc -8))
  519.           (bx-out writer writearg  (logand crc #xff)))))))
  520.  
  521.       
  522. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  523. ;;;
  524. ;;; Binhex front end 
  525.  
  526. (defvar *binhex-menu* (make-instance 'menu :menu-title "Binhex" 
  527.                                            :help-spec "Use this menu to encode and decode files in Binhex format."))
  528.  
  529.  
  530.  
  531. (defun binhex-error (string &rest args)
  532.   (declare (dynamic-extent args))
  533.   (let ((car (car args)))
  534.     (when (streamp car)
  535.       (setq args (cons 
  536.                   (cond ((typep car 'file-stream)(pathname car))
  537.                         (t "the selection"))
  538.                   (cdr args)))))
  539.   (ok-cancel-dialog (apply 'format nil string args)))
  540.  
  541. ;;; The dialog used to complain about suspicious file contents.
  542.  
  543.  
  544. ;;; Create and install the binhex menu
  545. (defun binhex-setup ()
  546.   (let ((menu *binhex-menu*))
  547.     (add-new-item menu "Binhex Encode…"
  548.                   'binhex-encode-get-file 
  549.                   :help-spec "Select this to encode a file in Binhex 4.0 format")
  550.     (add-new-item menu "Binhex Decode…"
  551.                   'binhex-decode-get-file
  552.                   :Help-spec "Select this to decode a Binhex 4.0 file")
  553.     (add-new-item menu "Decode Selection…"
  554.                   'binhex-decode-fred
  555.                   :class 'window-menu-item
  556.                   :update-function 'decode-selection-update
  557.                   :help-spec "Select this to decode a selection in a Fred window")
  558.     (menu-install menu)))
  559.  
  560. ;;; Enable  the menu item if there is a selection, otherwise disable it.
  561. (defun decode-selection-update  (item)
  562.   (let ((w (front-window)))
  563.     (when w
  564.       (multiple-value-bind (b e)(selection-range w)
  565.         (cond
  566.          ((and b e (neq b e) (> (- e b) (length full-header)))
  567.           (menu-item-enable item))
  568.          (t (menu-item-disable item)))))))
  569.  
  570. ;;;Decode a selection in a fred-window
  571. (defun binhex-decode-fred (w)
  572.   (multiple-value-bind (b e)(selection-range w)
  573.     (when (and b e (neq b e))
  574.       (let ((stream (make-instance 'fred-input-stream
  575.                       :buffer (fred-buffer w)
  576.                       :start b
  577.                       :end e)))
  578.         (binhex-decode-stream stream)))))
  579.  
  580. (defun binhex-encode-get-file ()
  581.   (let ((infile (catch-cancel (choose-file-dialog :button-string "Encode"))))
  582.     (unless (eq infile :cancel)
  583.       (binhex-encode-get-outfile infile))))
  584.  
  585. (defun binhex-encode-get-outfile (infile)
  586.   (let ((outfile 
  587.          (catch-cancel 
  588.            (choose-new-file-dialog  
  589.             :directory (make-pathname :directory (directory-namestring infile)
  590.                                       :name (file-namestring infile)
  591.                                       :type "hqx"
  592.                                       :defaults NIL)))))
  593.       (unless (eq outfile :cancel)
  594.         (binhex-encode infile outfile))))
  595.  
  596. (defun binhex-decode-get-file ()
  597.   (let ((infile (catch-cancel (choose-file-dialog :button-string "Decode" :mac-file-type :TEXT))))
  598.     (unless (eq infile :cancel)
  599.       (binhex-decode infile))))
  600.  
  601. ;;;;;;;;;;;;;;;;
  602. ;;
  603. ;; below extracted from examples;icon-dialog-item.lisp
  604. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  605. ;;
  606. ;;  plot-icon
  607. ;;
  608. ;;  a function for displaying icons.  It can be passed a pointer or a number
  609. ;;    if passed a pointer, it assumes this is a pointer to an icon record.
  610. ;;    if passed a number, it assumes this is the resource id of an icon.
  611. ;;    Draws to the current grafport, so call it inside WITH-FOCUSED-VIEW.
  612.  
  613. (defun plot-icon (icon point size &optional color-p)
  614.   "draws icon at point with given size"
  615.   (unless (or (typep icon 'fixnum)
  616.               (pointerp icon))
  617.     (error "~s is not a valid icon (not a resource-id or pointer"))
  618.   (with-macptrs ((resource (%null-ptr)))        ; don't cons macptr's
  619.     (without-interrupts
  620.      (when (typep icon 'fixnum)
  621.        (if color-p
  622.          (%setf-macptr resource (#_getCicon icon))
  623.          (%setf-macptr resource (#_geticon icon)))
  624.        (when (%null-ptr-p resource)
  625.          (error "no icon resource with id ~s ." icon))
  626.        (setq icon resource))
  627.      (rlet ((r :rect                         ;allocate a rectangle
  628.                :topleft point
  629.                :bottomright (add-points point size)))
  630.        (if color-p
  631.          (#_plotCicon r icon)
  632.          (#_ploticon r icon))))))
  633.  
  634. (defconstant *warn-icon* 2)
  635.  
  636. (defclass icon-dialog-item (dialog-item)
  637.   ((icon :initform *warn-icon* :initarg :my-icon :initarg :icon :accessor icon)
  638.    (color-p :initform nil :initarg :color-p :accessor color-p)))
  639.  
  640. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  641. ;;
  642. ;;  view-default-size
  643. ;;
  644.  
  645. (defmethod view-default-size ((view icon-dialog-item))
  646.   #@(32 32))
  647.  
  648.  
  649. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  650. ;;
  651. ;;  set-view-size
  652. ;;  The default method does not invalidate the old rectangle
  653. ;;
  654.  
  655. (defmethod set-view-size :before ((view icon-dialog-item) h &optional v)
  656.   (declare (ignore h v))
  657.   (invalidate-view view))
  658.  
  659.  
  660. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  661. ;;
  662. ;;  view-draw-contents
  663. ;;
  664. ;;this is the function called by the system whenever it needs to draw the item
  665. ;;
  666. ;;
  667.  
  668. (defmethod view-draw-contents ((item icon-dialog-item)) 
  669.   (plot-icon (icon item) (view-position item) (view-size item) (color-p item)))
  670.  
  671. (defun ok-cancel-dialog (message &key (size #@(318 145))
  672.                                  (position (list :top (+ 2 *menubar-bottom*)))
  673.                                  (ok-text "Ok")
  674.                                  (cancel-text "Cancel"))
  675.   (modal-dialog
  676.    (make-instance 'keystroke-action-dialog ;  allows typing first char of button text
  677.      :window-type :double-edge-box
  678.      :view-size size
  679.      :view-position position
  680.      :window-show nil
  681.      :help-spec "This dialog appears when Binhex suspects that a file may be corrupt"
  682.      :view-subviews
  683.      `(
  684.        ,(make-dialog-item 'static-text-dialog-item
  685.                         #@(20 50) (subtract-points size #@(30 50))
  686.                         message nil :help-spec "The file Binhex is encoding or decoding")
  687.        ,(make-dialog-item 'icon-dialog-item
  688.                           #@(20 12)
  689.                           #@(32 32)
  690.                           "Untitled"
  691.                           Nil
  692.                           :icon *warn-icon*)
  693.       ,@(if ok-text
  694.           `(,(make-dialog-item (if cancel-text 'button-dialog-item 'default-button-dialog-item)
  695.                         (make-point (subtract-points size (if cancel-text #@(200 27) #@(102 27))))
  696.                         #@(74 18) ok-text
  697.                         #'(lambda (item)
  698.                             (declare (ignore item))
  699.                             (return-from-modal-dialog nil))
  700.                         :help-spec "Choose this if you feel lucky")))
  701.       ,@(if cancel-text
  702.         `(,(make-dialog-item 'default-button-dialog-item 
  703.                           (subtract-points size #@(102 27))
  704.                           #@(74 18) cancel-text
  705.                           #'(lambda (item)
  706.                               (declare (ignore item)) 
  707.                               (return-from-modal-dialog :cancel))
  708.                           :help-spec "Choose this to cease decoding or encoding the file")))))))
  709.  
  710.  
  711.  
  712. (unless (find-menu "Binhex") (binhex-setup))
  713.  
  714. ;;;;;;;;;;;;;;;
  715. ;;; standalone application stuff
  716. ;;;
  717.  
  718.  
  719. ;;; define a bit-bucket stream and a few methods
  720. ;;; Somewhere I saw the idea of making a bit-bucket stream as an empty broadcast stream
  721.  
  722. #|
  723. (defclass bit-bucket (output-stream) ())
  724.  
  725. (defmethod stream-tyo ((s bit-bucket) char)
  726.   (declare (ignore s char)))
  727.  
  728. (defmethod stream-write-string ((s bit-bucket) string start end)
  729.   (declare (ignore s string start end)))
  730.  
  731. (defmethod stream-fresh-line ((s bit-bucket))
  732.   (declare (ignore s)))
  733.  
  734. (defmethod stream-force-output ((s bit-bucket))
  735.   (declare (ignore s)))
  736. |#
  737.  
  738. (defparameter *bit-bucket* (make-instance 'broadcast-stream :streams nil))
  739.  
  740. (defparameter *debugging* nil "Set to 0 for break-loop on error, 1 for backtrace to a file") 
  741.  
  742. ; the condition handler for serious-error (the superclass of error)
  743. (defun binhex-unexpected-error (c)
  744.     (case *debugging*
  745.       (0
  746.        (setq *terminal-io* (make-instance 'terminal-io)
  747.              *error-output* *terminal-io*
  748.              *standard-output* *terminal-io*
  749.              *debug-io* *pop-up-terminal-io*)
  750.        (set-menubar *default-menubar*)
  751.        (%set-toplevel #'toplevel-loop)
  752.        (signal c))
  753.       (1 (handler-bind
  754.            ((serious-condition #'quit-bx))
  755.              (let ((file (make-pathname :name (format nil "~D" (get-universal-time))
  756.                                         :type "report"
  757.                                         :directory '(:absolute "binhex-errors")
  758.                                         :host "home"
  759.                                         :defaults nil)))
  760.                (with-open-file (s file :direction :output)
  761.                  (let ((*error-output* s)
  762.                        (*debug-io* s))
  763.                    (typecase c
  764.                      (condition (report-condition c s))
  765.                      (string (princ c s)))
  766.                    (print-call-history)))))
  767.        (quit-bx nil))
  768.       (t (quit-bx nil))))
  769.  
  770.  
  771. (defun binhex-file-error (c)
  772.   (let ((string (report-condition c nil)))
  773.     (ok-cancel-dialog  string :ok-text nil)
  774.     (toplevel)))
  775.  
  776. ; the condition handler for warnings
  777. (defun binhex-ignore (&rest args)
  778.   (declare (ignore args)))
  779.  
  780.  
  781. (defun quit-bx (ignore)
  782.   (declare (ignore ignore))
  783.   ; command-. lets one escape from message-dialog
  784.   ; The unwind protect assures that we always quit
  785.   (unwind-protect
  786.     ; it would be cool to quit after 2 minutes
  787.     (message-dialog "Something horrible has happened" :ok-text "Die")
  788.     (quit)))
  789.  
  790. ;;; The regular toplevel function just hangs out waiting for (menu) events 
  791. (defun binhex-toplevel ()
  792.   (let ((*error-output* *bit-bucket*)
  793.         (*debug-io* *bit-bucket*)
  794.         (*standard-output* *bit-bucket*)
  795.         (*terminal-io* *bit-bucket*)
  796.         (*print-escape* nil)
  797.         (*print-pretty* nil)
  798.         ; below not necessary if we only use ~A
  799.         (*print-readably* nil))
  800.     (handler-bind
  801.        ((file-error #'binhex-file-error)
  802.         (serious-condition #'binhex-unexpected-error)
  803.         (warning #'binhex-ignore))
  804.       ; should this be (event-dispatch t) ?
  805.       (loop (event-dispatch t)))))
  806.  
  807. ;;; The initial toplevel function installs the regular toplevel function
  808. ;;; and decodes any finder selected files
  809. (defun binhex-startup ()
  810.   (let ((*error-output* *bit-bucket*)
  811.         (*debug-io* *bit-bucket*)
  812.         (*print-escape* nil)
  813.         (*print-pretty* nil)
  814.         (*print-readably* nil)))    
  815.   (%set-toplevel #'binhex-toplevel)
  816.   (handler-bind
  817.     ((file-error #'binhex-file-error)
  818.      (serious-condition #'binhex-unexpected-error)
  819.      (warning #'binhex-ignore))
  820.     (setq *application* (make-instance 'binhex-application))
  821.     ; process finder selected files if any    
  822.     (let ((file-list (finder-parameters)))
  823.       (when (eq (car file-list) :open)
  824.         (dolist (f (cdr file-list))
  825.           (open-application-document *application* f t))))))
  826.  
  827. ; open and print document handlers
  828. (defmethod print-application-document ((a binhex-application) file &optional startup)
  829.   (declare (ignore startup file)))
  830.  
  831. (defmethod open-application-document ((a binhex-application) file &optional startup)
  832.   (declare (ignore startup))
  833.   (let ((type (mac-file-type file)))
  834.     (if (eq type :text)
  835.       (binhex-decode file))))
  836.   
  837.  
  838. ;;; Get the menubar in the desired state for the standalone application.
  839. ;;; Then call save-application with the desired toplevel function and creator
  840.  
  841. (defun load-and-detach (type id)
  842.   (let* ((res (#_get1resource type id)))
  843.     (#_loadresource res)
  844.     (res-error)
  845.     (#_detachresource res)
  846.     (#_HNoPurge res)
  847.     res))
  848.  
  849.  
  850. (defun save-binhex (path)
  851.   (let* ((apple *apple-menu*) 
  852.          (edit (make-instance 'menu :menu-title "Edit"))
  853.          file resources)
  854.     (require "HELP-MANAGER")
  855.     ; because the apple menu is handled specially, if we
  856.     ; try to make a new one, we end up with two.
  857.     (apply 'remove-menu-items apple (menu-items apple))
  858.     ; Put "about binhex" in the apple menu
  859.     (add-menu-items apple                    
  860.                     (make-instance 'menu-item
  861.                       :menu-item-title "About Binhex"
  862.                       :menu-item-action 'about-binhex)
  863.                     (make-instance 'menu-item
  864.                       :menu-item-title "-"))
  865.     (remove-menu-items *binhex-menu* 
  866.                        (find-menu-item *binhex-menu* "Decode Selection…"))
  867.     (setq file (make-instance 'menu
  868.                  :menu-title "File"))
  869.     (add-menu-items file 
  870.                     (make-instance 'menu-item
  871.                       :menu-item-title "Quit"
  872.                       :menu-item-action #'quit
  873.                       :command-key #\Q))
  874.     ; For da's under unifinder. Binhex itself has nothing to edit.
  875.     (let ((undo-item (or (find-menu-item *edit-menu* "Undo")
  876.                          (find-menu-item *edit-menu* "Redo")
  877.                          ; the darn thing can also be e.g. "Undo Typing"
  878.                          (car (slot-value *edit-menu* 'item-list)))))
  879.       (set-menu-item-title undo-item "Undo")
  880.       (add-menu-items edit
  881.                       undo-item
  882.                       (find-menu-item *edit-menu* "-")
  883.                       (find-menu-item *edit-menu* "Cut")
  884.                       (find-menu-item *edit-menu* "Copy")
  885.                       (find-menu-item *edit-menu* "Paste")
  886.                       (find-menu-item *edit-menu* "Clear"))
  887.       (set-menubar (list apple file edit *binhex-menu*)))
  888. ; The resource file contains icon ("ICN#", "icl8", etc.) resources for the
  889. ; application (id #128) and for the documents that it creates (id #129)
  890. ; and appropriate "FREF" and "BNDL" resources.
  891. ; MCL contains a resource of type "CCL2" and icon and "FREF" resources for
  892. ; a larger set of document types (ids in the range 128-132).
  893.     (with-open-resource-file (f "ccl:examples;binhex;binhex resources.rsrc")
  894.       (do* ((id 128 (1+ id)))
  895.            ((> id 132))
  896.         (dolist (type '("FREF" "ics#" "ICN#" "icl4" "icl8" "ics4" "ics8"))
  897.           (push (list (if (<= id 129) (load-and-detach type id)) type id) resources)))
  898.       ; We don't want a "CCL2" resource ...
  899.       (push (list nil "CCL2" 0) resources)
  900.       ; We -do- want a resource of type binhex-file-creator ...
  901.       (push (list (#_NewHandle 0) binhex-file-creator 0 "MCL Binhex Example") resources)
  902.       ; Grab "BNDL"(128) from our resource file, replacing MCL's
  903.       (push (list (load-and-detach "BNDL" 128) "BNDL" 128) resources))
  904.     (catch-cancel
  905.       (save-application path :init-file nil :toplevel-function #'binhex-startup
  906.                         :creator binhex-file-creator :resources resources :excise-compiler T))
  907.     ; in case the save is cancelled
  908.     (set-menubar *default-menubar*)))
  909.  
  910. (defun about-binhex ()
  911.   (modal-dialog
  912.      (make-instance 'dialog
  913.             :view-position '(:top 100)
  914.             :view-size #@(180 150)
  915.             :window-type :double-edge-box
  916.             :window-show nil
  917.             :view-subviews
  918.               (list
  919.                (make-dialog-item 'default-button-dialog-item
  920.                  #@(55 120) #@(70 18) "OK"
  921.                  #'(lambda (item)
  922.                      (declare (ignore item))
  923.                      (return-from-modal-dialog t)))
  924.                (make-dialog-item 'static-text-dialog-item
  925.                  #@(5 5) #@(290 55) (format nil "Binhex in~%~a~%~a"
  926.                                             (lisp-implementation-type)
  927.                                             (lisp-implementation-version))
  928.                  nil
  929.                  :view-font '("geneva" 12 :bold))
  930.                (make-dialog-item 'static-text-dialog-item
  931.                  #@(5 60) #@(180 40)  "
  932.   Apple Computer, Inc." nil 
  933.                  :view-font '("geneva" 12))
  934.                ))))
  935.  
  936.  
  937.   
  938.  
  939.  
  940.  
  941.  
  942.  
  943.        
  944.        
  945.  
  946.